perm filename TEXDOC.SAI[TEX,DEK]2 blob
sn#430108 filedate 1979-04-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00008 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 begin "texdoc" comment This is an experimental program that converts structured
C00020 00003 Lookup procedures
C00029 00004 Outline of the finite-state scanner for phase 1
C00037 00005 Preparations for the recursive-descent scanner in Phase 2
C00041 00006 Scanning procedures for phase 2
C00064 00007 Phase 1
C00076 00008 Phase 2
C00081 ENDMK
C⊗;
begin "texdoc" comment This is an experimental program that converts structured
"top-down" documentation into a suitable format for printing. The input is a
.DOC file having the form described at the beginning of UNDOC.SAI, while the
output will be in a corresponding .TEX file ready for typesetting.
The .TEX file output is arranged in numbered sections. A new section number
occurs for each blank line or end-of-page in the input .DOC file.
TEXDOC does its job in two phases. First it reads the entire source file into main
memory, collecting cross-reference information as it goes. This first phase is
similar to the UNDOC program, and in fact it has deliberately been written so that
the analogies are clear (at the expense of a little bit of efficiency). Then
TEXDOC spews out all the results, in a second phase that is similar to the
BLAISE program.
;
require "⊂⊃⊂⊃" delimiters; "used for macros"
define # = ⊂;comment⊃; "used henceforth instead of quoted comments like this"
define nextline = ⊂('15&'12)⊃ # carriage-return and line-feed in print commands;
define thru = ⊂step 1 until⊃ # abbreviation for for clauses;
define DEBUGONLY = ⊂comment⊃ # changed to ⊂⊃ when debugging;
define saf = ⊂safe⊃ # used when an array is believed to require no bounds checks;
DEBUGONLY redefine saf = ⊂⊃ # when debugging, belief turns to disbelief;
DEBUGONLY external procedure bail # the SAIL debugger in case of need;
require 25000 string_space;
require 400 system_pdl;
require 100 string_pdl;
label phase2 # go here when phase 1 is finished;
label finalend # go here when phase 2 is finished;
integer ichan,ochan,brchar,eof,lineno,pageno # standard variables of input system;
string filename,inputfile,outputfile # variables relating to file names;
string saf array fn[0:2] # components of file name;
procedure scanfilename # parses filename, puts parts in the fn array;
begin integer t # (0,1,2) for (name,ext,ppn);
string s # temporary storage;
integer c # current character of string;
s←filename; t←0; fn[0]←fn[1]←fn[2]←"";
while (c←lop(s)) do
begin if c="." then t←1 else if c="[" then t←2;
fn[t]←fn[t]&c;
end;
end;
procedure initio # initialize input and output;
begin while true do
begin print("Input file: "); filename←inchwl; scanfilename;
if fn[1]=0 then fn[1]←".DOC";
inputfile←fn[0]&fn[1]&fn[2];
open(ichan←getchan,"DSK",0,19,0,100,brchar,eof);
lookup(ichan,inputfile,eof);
if not eof then done;
print("Lookup failed on file ",inputfile,"!",nextline);
release(ichan);
end;
while true do
begin fn[1]←".TEX";
outputfile←fn[0]&fn[1]&fn[2];
print("Output file (default = ",outputfile,"): ");
filename←inchwl;
if filename then
begin scanfilename;
outputfile←fn[0]&fn[1]&fn[2];
end;
open(ochan←getchan,"DSK",0,0,19,0,0,eof);
enter(ochan,outputfile,eof);
if not eof then done;
print("Can't write on file ",outputfile,"!",nextline);
release(ochan);
filename←inputfile; scanfilename;
end;
setprint("errors.tmp","B") # output goes to file as well as to user terminal;
setbreak(1,'14,null,"INA") # input(ichan,1) will read up to and including <FF>;
end;
integer cursec # current section number (beginning with 1);
string inbuf,curbuf # buffers while reading;
procedure error(string s) # prints a message to report an anomaly;
print(nextline,"p.",pageno,",l.",lineno,": ",s);
procedure error2(string s) # errors in phase 2;
begin integer n,m;
print(nextline,"! ",s,".",nextline,"(in section ",cursec,") ");
n←length(inbuf); m←length(curbuf); n←n-m;
if n≤50 then print(inbuf[1 to n]) else print("...",inbuf[n-50 to n]);
if m≤50 then print('12&curbuf) else print('12&curbuf[1 to 50]&"...");
end;
procedure overflow(string s) # prints error message and aborts phase 1;
begin error("Capacity exceeded ("); print(s,"), some input is lost.");
go to phase2;
end;
procedure overflow2(string s) # prints error message and dies;
begin print(nextline,"Capacity exceeded in phase 2 (",s,"), must quit.");
go to finalend;
end;
define memsize=10000 # size of mem;
integer saf array mem[0:memsize] # memory for instructions and cross-references;
define info(p)=⊂(mem[p] lsh -18)⊃ # left half of mem[p];
define link(p)=⊂(mem[p] land '777777)⊃ # right half of mem[p];
define stop=0,newsec=1,def0=2,def1=3,def2=4,def3=5,def4=6,
txt=7,comt=8,ttl=9 # op-codes;
integer m # the current instruction, starts at 1 and increases;
integer mm # the previous cross ref, starts at memsize and decreases;
procedure compile(integer op,adr) # used to store the next "instruction";
begin if m≥mm then overflow("memsize");
mem[m]←(op lsh 18)+adr; m←m+1;
end;
procedure xref(integer no,lnk) # used to insert a cross reference;
begin if m≥mm then overflow("memsize");
mm←mm-1; mem[mm]←(no lsh 18)+lnk;
end;
define txtsize=10000 # number of text strings;
string saf array texts[0:txtsize] # nontitle texts;
integer txtptr # the number of stored texts;
integer curtitle # pointer to current title being defined in phase 2;
integer nn # section number of the title most previously processed by p_title;
integer tlineno # line number where current title began;
comment Lookup procedures;
comment Titles are stored in two conventional binary search trees, whose
nodes contain the following fields:
str[k], the title stored at node k (a string) followed by "}",
left[k], left son of node k,
right[k], right son of node k,
eq[k], the defined equivalent of node k.
xr[k], pointer to the list of all section numbers where node k is used.
Constant and macro titles appear in a tree whose root is conroot, other titles
appear in a tree whose root is titlroot. The value eq[k] for constants is the
section number where that constant is defined, for undefined identifiers it is zero,
and for macros it is the negative of the section number. The value of eq[k] for
other titles is either 0 (undefined) or positive (the section number of
definition) or negative (the negative of a pointer to the list of cross-references
to all sections where this title has been defined). When str[k] is a reserved word,
xr[k] is the negative of the type code of that reserved word used in phase 2.
;
define strsize=1500 # number of different titles allowed;
string saf array str[0:strsize] # title names;
integer saf array left,right,eq,xr[0:strsize] # sons and equivalents;
integer nstrs # number of nodes in the tree;
integer titlroot,conroot # roots of trees;
integer procedure findabbr(string x) # looks for an abbreviated title;
begin comment If x is not the abbreviation of a unique title, an error
message is given and 0 is returned. Otherwise the index k such that x is a
prefix of str[k] is returned;
label ambig # go here if there's more than one match;
label errorprint # go here to complete the error message;
string xx # x with the closing "..." removed;
xx←x[1 to ∞-3];
if xx[∞ to ∞] = " " then xx←xx[1 to ∞-1];
if titlroot then
begin integer k # current node;
integer l # the length of xx;
k←titlroot; l←length(xx);
while true do
begin string s,t; integer d;
if equ(xx,str[k][1 to l]) then
begin integer p;
if (p←left[k]) then
begin while right[p] do p←right[p];
if equ(xx,str[p][1 to l]) then go to ambig;
end;
if (p←right[k]) then
begin while left[p] do p←left[p];
if equ(xx,str[p][1 to l]) then go to ambig;
end;
return(k);
end;
s←xx; t←str[k];
while (d←lop(s)-lop(t))=0 do;
if d<0 then k←left[k] else k←right[k];
if k=0 then done;
end;
end;
error("Unmatched"); go to errorprint;
ambig: error("Ambiguous");
errorprint: print(" abbreviation: {",x,"}."); return(0);
end;
integer procedure find(string x; integer mode) # looks for the title name x;
begin comment If mode=0, this procedure finds x in the title tree, inserting
x if x wasn't already present. If mode=1, this procedure similarly finds x in
the constant tree. If mode=2, this procedure looks for x in the constant tree,
but doesn't insert it. The value returned is the node where x was found, or 0
if it wasn't;
integer k # current node;
integer lnk # pointer to new node if insertion needs to be done;
string xx # x with a right brace after it;
xx←x&"}";
case mode of begin
[0] begin if equ(x[∞-2 to ∞],"...") then return(findabbr(x));
k←titlroot; lnk←nstrs+1 end;
[1] begin k←conroot; lnk←nstrs+1 end;
[2] begin k←conroot; lnk←0 end
end;
if k=0 then
if mode then conroot←lnk else titlroot←lnk
else while true do
begin string s,t; integer d;
if equ(xx,str[k]) then return(k);
s←xx; t←str[k];
while (d←lop(s)-lop(t))=0 do;
comment No string will be a prefix of another since they end with "}";
if d<0 then
if left[k] then k←left[k]
else begin left[k]←lnk; done;
end
else if right[k] then k←right[k]
else begin right[k]←lnk; done;
end;
end;
if lnk then
begin if lnk≥strsize then overflow("strsize");
str[nstrs←lnk]←xx; eq[nstrs]←left[nstrs]←right[nstrs]←xr[nstrs]←0;
end;
return(lnk);
end;
integer procedure reverse(integer p) # reverses the reference list starting at p;
begin integer q,r;
q←0; while true do
begin r←link(p);
mem[p]←(mem[p] land '777777000000)+q;
if r=0 then return(p);
q←p; p←r;
end;
end;
procedure outlist(integer p) # outputs a list of references;
begin if link(p) then
begin comment more than one reference;
out(ochan,"s ") # makes preceding word plural;
out(ochan,cvs(info(p))); p←link(p);
if link(p) then
begin comment more than two references;
integer n; n←20;
while true do
begin out(ochan,", ");
if n=0 then
begin out(ochan,nextline) # avoid long line;
n←20;
end
else n←n-1;
out(ochan,cvs(info(p))); p←link(p);
if link(p)=0 then done;
end;
out(ochan,", ");
end;
out(ochan," and");
end;
out(ochan," "); out(ochan,cvs(info(p))); out(ochan,".");
end;
recursive procedure outtree(integer p) # prints cross-references in subtree p;
if p then
begin outtree(left[p]);
if xr[p]>0 then
begin integer q;
integer n; n←20;
out(ochan,"\\");
out(ochan,str[p][1 to ∞-1]);
out(ochan,":");
if eq[p] then
begin out(ochan,"\&{");
out(ochan,cvs(abs(eq[p]))); out(ochan,"}, ");
end;
q←reverse(xr[p]); while true do
begin out(ochan,cvs(info(q)));
q←link(q);
if q=0 then done;
out(ochan,", ");
if n=0 then
begin out(ochan,nextline) # avoid long line;
n←20;
end
end;
out(ochan,"."&nextline);
end;
outtree(right[p]);
end;
comment Outline of the finite-state scanner for phase 1;
comment Here are the different types of character codes distinguished:;
define space=0 # space or tab;
define lf=1 # line-feed;
define cr=2 # carriage-return;
define ff=3 # form-feed;
define letter=4 # A...Z or a...z or _;
define digit=5 # 0...9;
define apost=6 # ';
define plus=7 # +;
define minus=8 # -;
define colon=9 # :;
define equals=10 # =;
define lbrace=11 # {;
define rbrace=12 # };
define lpren=13 # (;
define rpren=14 # );
define hash=15 # #;
define other=16 # none of the above;
define charcodes=other+1 # the number of different character types recognized;
preload_with [8] other,
other, space, lf, other, ff, cr, [2] other,
[8] other,
letter, [7] other,
space, [2] other, hash, [3] other, apost,
lpren, rpren, other, plus, other, minus, [2] other,
[8] digit,
[2] digit, colon, [2] other, equals, [2] other,
other, [7] letter,
[16] letter,
[3] letter, [5] other,
other, [7] letter,
[16] letter,
[3] letter, lbrace, [2] other, rbrace, other;
integer saf array chartype[0:'177];
comment The state of the scanner appears in variable "state" and also in
a few other variables;
integer state # the scanner state;
integer c # the current character;
string id # current identifier being scanned;
integer defplace # current constant;
integer op # pending operator on constant;
string accum # current value of constant;
integer bal # excess of {'s over }'s;
integer lastc # previous character (maintained only when scanning comments);
integer deftype # type of title definition;
integer curdef # location of instruction preceding the current definition,
or -1 if no definition is in progress;
string radix # "'" or "" when scanning constants;
string val # current value of identifier or constant being scanned;
string texte # the current string being compressed from the input;
comment The scanner states have the following significance:
normal, outside of titles when nothing special is active.
normal1, like normal but immediately following a line-feed.
title1, just after scanning the opening { of a title.
title2, scanning during the middle of a title.
title3, just after scanning the closing } of a title.
skipspaces, scanning titles when spaces are ignored.
skipcomment, scanning comment titles.
skipcr, skipping spaces and carriage-returns at beginning of a definition.
ident, scanning an identifier.
const, beginning of a constant.
const1, after a constant has begun.
During states ident, const, and const1, the value of op is 0 if there's no
operation pending, otherwise op is "+" or "-" and accum contains the value of
the current constant before the pending operation. Also defplace is 0 if the
current constant is not in a definition, otherwise it is the location of the
constant identifier being defined;
define normal=0, normal1=normal+charcodes, title1=normal1+charcodes,
title2=title1+charcodes, title3=title2+charcodes, skipspaces=title3+charcodes,
skipcomment=skipspaces+charcodes, skipcr=skipcomment+charcodes,
ident=skipcr+charcodes, const=ident+charcodes, const1=const+charcodes;
comment The following procedures do some of the most important operations
needed during the scanning process;
procedure storetext # call this when texte needs to be stored;
begin texts[txtptr]←texte; texte←"";
compile(txt,txtptr);
if txtptr≥txtsize then overflow(txtsize);
txtptr←txtptr+1;
end;
procedure startdef # call this when a definition is beginning;
begin if curdef≥0 then
begin error("Definition within a definition.");
state←skipcr;
end
else if deftype<2 then
begin comment Non-constant definition;
defplace←find(texte,0); state←skipcr; curdef←m;
cursec←cursec+1;
if defplace=0 or eq[defplace]=0 then eq[defplace]←cursec
else begin comment Appending to a definition; integer j; j←eq[defplace];
if deftype=0 then error("Double definition of {"&str[defplace]&".");
if j>0 then
begin xref(j,0); j←-mm;
end;
xref(cursec,-j); eq[defplace]←-mm;
end;
end
else begin comment Constant or macro definition; defplace←find(texte,1);
if eq[defplace] or xr[defplace] then
error("Double definition of {"&str[defplace]&".");
if deftype=2 then
begin op←0; state←const; radix←""; eq[defplace]←cursec;
end
else begin state←skipcr; curdef←m; eq[defplace]←-cursec;
end;
end;
texte←""; compile(def0+deftype,defplace);
end;
procedure finishdef # call this when a definition has ended;
begin if texte then storetext; curdef←-1;
end;
procedure processcon # call this when the character after a constant was scanned;
begin if op=0 then accum←val else if op="+" then accum←accum&"+"&val else
if op="-" then accum←accum&"-"&val;
if c="+" or c="-" then
begin state←const; op←c;
end
else if defplace>0 then
begin texte←accum; state←skipcr;
end
else begin texte←texte&accum; state←normal;
end;
end;
procedure finishid # used when leaving ident state;
begin if op then texte←texte&accum&op;
if defplace>0 then error("Undefined constant.");
state←normal;
end;
comment Preparations for the recursive-descent scanner in Phase 2;
define space2=1,letter2=2,digit2=3,doublequote2=4,singlequote2=5,lpren2=6,dot2=7,
lbr2=8,ident2=9,const2=10,otherchar2=11,star2=12,t_up=13,doubledots2=14,comma2=15,
colon2=16,t_comment=17,semi2=18,t_close=19,t_string=20,t_program=21,t_var=22,
t_procedure=23,t_begin=24,t_packed=25,t_to=26,t_div=27,t_nil=28,t_record=29,
t_array=30,t_of=31,t_case=32,t_repeat=33,t_until=34,t_then=35,t_if=36,
t_exit=37,t_end=38,underline2=39,t_else=40,t_eof=41,t_file=42,t_for=43,t_title=44,
hash2=45,t_def2=46,t_def3=47,t_def4=48,t_label=49
# arbitrary codes used in the scanner;
preload_with t_eof, [7] otherchar2,
otherchar2, [3] space2, t_eof, space2, [2] otherchar2,
[8] otherchar2,
underline2, [7] otherchar2,
space2, otherchar2, doublequote2, hash2, [3] otherchar2, singlequote2,
lpren2, t_close, star2, otherchar2, comma2, otherchar2, dot2, otherchar2,
[8] digit2,
[2] digit2, colon2, semi2, [4] otherchar2,
t_up, [7] letter2,
[16] letter2,
[3] letter2, lbr2, otherchar2, t_close, t_up, otherchar2,
singlequote2, [7] letter2,
[16] letter2,
[3] letter2, [5] otherchar2;
saf integer array chartype2[0:'177] # types for SUAI ascii in phase 2;
string curstr # the current translated string;
define cr2='15, c5='14, c0='12, c2='13 # characters interpreted by the
putout procedure;
integer state2 # if nonzero, this is substituted for the 0 or 2 in \0 or \2;
integer lastout # the last character that was putout (prevents consec cr's);
string putstr # parameter to putout;
procedure putout # sends putstr to output, slightly interpreting it;
begin integer c;
while true do
begin c←lop(putstr);
case c of begin
[0] done;
["\"] if putstr="6" then
begin while true do
begin out(ochan,c);
if c="\" and putstr="7" then done;
c←lop(putstr);
end;
end
else if state2 and (putstr="0" or putstr="2") then
begin out(ochan,"\"); out(ochan,state2); state2←0; c←lop(putstr);
lastout←"\" # a little white lie;
end
else begin out(ochan,"\"); lastout←"\";
end;
[cr2] if lastout≠cr2 then begin out(ochan,nextline); lastout←cr2 end;
[c0] state2←"0";
[c2] if state2≠"5" then state2←"2";
[c5] state2←"5";
else begin out(ochan,c); lastout←c
end
end;
end;
end;
comment Scanning procedures for phase 2;
integer curtype # type of the token currently being scanned;
integer fillcount # increases by 1 when a new line or page is read;
boolean activity # getnext has been called;
string procedure p_title(integer n) # str[n] formatted as a title;
begin integer nl; string st;
nl←50; st←str[n][1 to ∞-1];
while length(st)>nl do
begin comment try to avoid long lines in the output;
integer c; string s; s←st[nl to ∞]; while true do
begin c←lop(s); if c=0 or c='40 then done;
end;
if c=0 then nl←length(st) else
begin integer k; k←length(st)-length(s); nl←nl+50;
st←st[1 to k-1]&nextline&s;
end;
end;
nn←eq[n]; if nn<0 then
begin nn←-nn; while link(nn) do nn←link(nn); nn←info(nn);
end
else if nn=0 then print(nextline,"Undefined title: {",str[n]);
return("\6"&st&"{ \:m"&cvs(nn)&"\7}");
end;
procedure getnext # gets the next input token;
begin comment The other phase2 procedures for scanning call this one whenever
the current character has been digested and it is time to read a new one.
This procedure is the lexical scanner. It processes identifiers, constants,
comments, "..", and ordinary single characters, setting curtype to the
appropriate code value. It also sets curstr equal to the translation of
the scanned token. Spaces in the input are ignored (except in strings and
comments);
integer c; label restart;
activity←true;
restart: if curbuf=0 then
begin case info(m) of begin
[stop][newsec][def0][def1] begin curtype←t_eof; return end;
[def2][def3][def4] begin curtype←info(m)+(t_def2-def2); curstr←
str[link(m)][1 to ∞-1]; m←m+1; return end;
[txt] begin inbuf←curbuf←texts[link(m)]; m←m+1; go to restart end;
[ttl] begin curtype←t_title; curstr←p_title(link(m));
m←m+1; return end;
[comt] begin curtype←t_comment; curstr←"$\{\;$"&texts[link(m)]&
("$\;\}$"&cr2&c2); m←m+1; return end;
else error2("Bug 3 in TEXDOC")
end;
end;
c←lop(curbuf); curtype←chartype2[c];
case curtype of begin
[space2] go to restart;
[letter2] begin curstr←c; while true do
begin c←chartype2[curbuf];
if c=letter2 or c=digit2 or c=underline2 then curstr←curstr&lop(curbuf)
else done;
end;
c←find(curstr,1); if xr[c]<0 then curtype←-xr[c] else begin curtype←ident2;
curstr←"\\{"&curstr&"}" end end;
[digit2] begin curstr←c; curtype←const2; while true do
begin c←chartype2[curbuf];
if c=digit2 then curstr←curstr&lop(curbuf)
else if c=letter2 then curstr←curstr&"\mathopen{\hbox{"&lop(curbuf)
&"}}"
else done;
end end;
[doublequote2] begin curstr←"\hbox{\char'16}"; curtype←otherchar2 end # octal;
[hash2] begin curstr←"\.{\char'43}"; curtype←otherchar2 end # parameter mark;
[singlequote2] begin curstr←c; curtype←t_string; while true do
begin c←lop(curbuf);
if c='40 then curstr←curstr&"\ "
else if c then
begin curstr←curstr&c;
if c="'" then done;
end
else begin error2("String constant didn't end on the line"); done;
end;
end end;
[dot2] if curbuf="." then
begin curtype←doubledots2; curstr←"\mathrel{\!.\,.\!}"; c←lop(curbuf);
end
else curstr←c;
else curstr←c
end;
end;
comment The recursive procedures below follow the syntax in BLAISE.SYN
fairly closely;
forward recursive string procedure p_fragment;
forward recursive string procedure p_genexp;
forward recursive string procedure p_outertoken;
forward recursive string procedure p_innertoken;
forward recursive string procedure p_token;
forward recursive string procedure p_speciallist;
forward recursive string procedure p_comments;
forward recursive string procedure p_variant;
forward recursive string procedure p_compoundstatement;
forward recursive string procedure p_statement1;
forward recursive string procedure p_noncompoundstatement;
forward recursive string procedure p_statement;
forward recursive string procedure p_case;
recursive string procedure p_fragment;
begin string str;
case curtype of begin
[t_program] begin str←"\3\2\&{"&curstr&"} "; getnext;
str←str&p_genexp&"\1" end;
[t_label] begin str←"\3\2\1\&{"&curstr&"} "; getnext;
while true do
begin case curtype of begin
[ident2][const2][t_title] begin str←str&"\0"&curstr; getnext end;
[comma2] begin str←str&curstr&"\45\ "; getnext end;
[t_comment] begin str←str&"\40\ "&curstr; getnext end;
else done
end
end end;
[t_var] begin str←"\3\2\1\&{"&curstr&"} "; getnext;
str←str&p_genexp end;
[t_procedure] begin str←"\3\2\1\1\&{"&curstr&"} "; getnext;
str←str&p_genexp end;
[t_begin] begin str←"\3\2"; str←str&p_compoundstatement end;
[t_def2] begin str←"\3\2\1\&{define} \\{"&curstr&"} $=$ ";
getnext; str←str&p_genexp end;
[t_def3][t_def4] begin str←"\3\2\1\&{define} \\{"&curstr; if curtype=t_def3 then
str←str&"}\.{(\char'43)} $≡$ " else str←str&"} $≡$ "; getnext;
if curtype=t_begin then str←str&"\2"&p_compoundstatement else str←str&p_genexp end;
else str←c2&p_noncompoundstatement
end;
return(str);
end;
recursive string procedure p_genexp;
begin string str; integer n;
n←50; str←""; while true do
begin case curtype of begin
[lpren2][dot2][lbr2][ident2][const2][otherchar2][star2]
[t_up][doubledots2][comma2]
[colon2][t_comment][t_string][t_record][t_packed][t_to][t_div][t_nil]
[t_array][t_file][t_title] str←str&p_outertoken;
else done
end;
if length(str)>n then
begin comment try to avoid long lines in output;
str←str&cr2; n←n+50;
end;
end;
if str then return("$"&str&"$") else return("");
end;
recursive string procedure p_outertoken;
begin string str;
case curtype of begin
[lpren2][lbr2][t_array][t_file] begin if curtype=t_array then
str←"\mathop{\&{"&curstr&" }}" else if curtype=t_file then
str←"\mathop{\&{"&curstr&"}\!}"
else str←curstr; getnext; while true do
begin integer n; n←50;
case curtype of begin
[lpren2][dot2][lbr2][ident2][const2][otherchar2][star2]
[t_up][doubledots2][comma2]
[colon2][t_comment][semi2][t_string][t_var][t_procedure][t_record][t_packed]
[t_to][t_div][t_nil][t_array][t_file][t_title] str←str&p_innertoken;
else done
end;
if length(str)>n then
begin comment try to avoid long lines in output;
str←str&cr2; n←n+50;
end;
end;
if curtype = t_close then
begin str←str&curstr; getnext;
end
else if curtype=t_of then
begin str←str&"\mathop{\&{\ "&curstr&" }\!}"; getnext;
end
else error2("Missing a closing symbol") end;
[ident2][const2][otherchar2][star2][t_up][t_packed][t_to][t_div][t_nil]
[t_title] str←p_token;
[dot2] begin str←curstr; getnext; str←str&p_token end;
[doubledots2] begin str←curstr; getnext end;
[comma2] begin str←curstr&"\45"; getnext end;
[colon2] begin str←"\mathrel"&curstr; getnext end;
[t_record] begin str←"\null$\1\2\&{"&curstr&"} "; getnext;
str←str&c0&p_speciallist;
if curtype=t_end then
begin str←str&c2&"\2\&{"&curstr&"}$\null\3"; getnext;
end
else begin error2("Missing end of record type"); str←str&"\3";
end end;
[t_comment] begin str←"\null$\40\ "&curstr&("$\null"&cr2); getnext end;
[t_string] begin str←"\.{"&curstr&"}"; getnext end;
else error2("Bug 1 in TEXDOC")
end;
return(str);
end;
recursive string procedure p_innertoken;
begin string str;
case curtype of begin
[lpren2][dot2][lbr2][ident2][const2][otherchar2][star2]
[t_up][doubledots2][comma2][colon2]
[t_comment][t_string][t_record][t_packed][t_to][t_div][t_nil]
[t_array][t_file][t_title] str←p_outertoken;
[semi2] begin str←curstr&"\42\,"; getnext end;
[t_var][t_procedure] begin str←"\mathop{\&{"&curstr&"}}"; getnext end;
else error2("Bug 2 in TEXDOC")
end;
return(str);
end;
recursive string procedure p_token;
begin string str;
case curtype of begin
[ident2][const2][otherchar2] begin str←curstr; getnext end;
[t_title] begin str←"\null$"&curstr&"$\null "; getnext end;
[t_packed] begin str←"\mathop{\&{"&curstr&" }\!}"; getnext end;
[t_to] begin str←"\mathrel{\&{"&curstr&"}}"; getnext end;
[t_up] begin str←"{\up}"; getnext end;
[star2] begin str←"{\ast}"; getnext end;
[t_div] begin str←"\mathbin{\&{"&curstr&"}}"; getnext end;
[t_nil] begin str←"\&{"&curstr&"}"; getnext end;
else error2("Missing token")
end;
return(str);
end;
recursive string procedure p_speciallist;
begin string str,str1,str2;
str←""; while true do
begin str2←p_genexp;
if str2 then str←str&"\2"&str2;
if curtype≠semi2 then done;
str←str&curstr; getnext;
str←str&p_comments;
end;
while curtype=t_case do
begin str←str&"\2\1\&{"&curstr&"} "; getnext;
str←str&p_genexp;
if curtype=t_of then
begin str←str&" \&{"&curstr&"}"; getnext;
end
else error2("Missing `of'");
while true do
begin str←str&p_variant;
if curtype≠semi2 then done;
str←str&curstr; getnext;
end;
str←str&"\3";
end;
return(str);
end;
recursive string procedure p_comments;
begin string str;
if curtype≠t_comment then return(cr2);
str←("\40\"&cr2)&curstr; getnext;
while curtype=t_comment do
begin str←str&"\2"&curstr; getnext;
end;
return(str);
end;
recursive string procedure p_variant;
begin string str;
str←p_comments;
case curtype of begin
[ident2][const2] ;
[t_title] curstr←"\null$"&curstr&"$\null ";
[comma2] curstr←curstr&"\45";
else return(str)
end;
str←str&(cr2&"\2\1$")&curstr; getnext;
while true do
begin case curtype of begin
[ident2][const2] ;
[t_title] curstr←"\null$"&curstr&"$\null ";
[comma2] curstr←curstr&"\45";
[t_comment] curstr←"\null$\40\ "&curstr&"$\null ";
[colon2] begin str←str&"\mathrel"&curstr; getnext; done end;
else begin error2("Improper token list in variant"); done;
end
end;
str←str&curstr; getnext;
end;
str←str&"\null$"&p_comments;
if curtype=lpren2 then
begin str←str&curstr&c0; getnext;
end
else error2("Missing `(' in variant");
str←str&p_speciallist;
if curtype=t_close then
begin str←str&curstr; getnext;
end
else error2("Missing `)' in variant");
str←str&p_comments;
return(str&"\3");
end;
recursive string procedure p_compoundstatement;
begin string str,str1; label recover;
str←"\&{"&curstr&"} "; getnext;
str←str&p_statement1;
recover: while curtype=semi2 do
begin str←str&curstr; getnext;
str←str&p_comments&p_statement;
end;
str←str&p_comments;
if curtype=t_end then
begin str←str&(c2&"\2\&{")&curstr&("}"&c2); getnext;
end
else begin error2("Missing `;'");
str1←p_statement; if str1 then
begin str←str&str1; go to recover;
end;
error2("Missing `end'");
str←str&(c2&"\2"&c2);
end;
return(str);
end;
boolean procedure labelpresent # looks ahead to see if colon and no equals is next;
begin integer c,d; label restart, quit;
restart: while chartype2[curbuf]=space2 do c←lop(curbuf);
if curbuf=0 then
begin if info(m)≠txt then go to quit;
inbuf←curbuf←texts[link(m)]; m←m+1; go to restart;
end;
if chartype2[curbuf]=colon2 then
begin label restart;
d←lop(curbuf);
restart: while chartype2[curbuf]=space2 do c←lop(curbuf);
if curbuf=0 then
begin if info(m)≠txt then
begin curbuf←d; go to quit;
end;
inbuf←curbuf←texts[link(m)]; m←m+1; go to restart;
end;
if curbuf≠"=" then return(true) else curbuf←d&curbuf;
end;
quit: return(false);
end;
recursive string procedure p_statement1;
begin string str,str1;
case curtype of begin
[t_comment] begin str←"\40\ "&curstr; getnext; while curtype=t_comment do
begin str←str&"\2"&curstr; getnext;
end;
str←str&p_statement end;
[t_begin] str←"\1"&p_compoundstatement&"\3";
[ident2][const2][t_title] if labelpresent then begin str←"\2"&curstr&": "; getnext;
str←str&p_statement1 end
else str←c0&p_noncompoundstatement;
else str←c0&p_noncompoundstatement
end;
return(str);
end;
recursive string procedure p_noncompoundstatement;
begin string str; integer tif;
case curtype of begin
[t_exit] begin str←"\2\&{"&curstr; getnext;
if curtype=t_if then
begin str←str&" "&curstr&"} "; getnext;
end
else begin error2("Missing `if'"); str←str&"}";
end;
str←str&p_genexp end;
[t_if][t_for] begin tif←curtype; str←"\2\1\&{"&curstr; getnext;
str←str&"} "&p_genexp;
if curtype=t_then then
begin str←str&" \&{"&curstr&"}"; getnext;
end
else begin error2("Missing `then' or `do'"); str←str&" ";
end;
str←str&p_comments&p_statement&("\3"&c2)&p_comments;
if tif=t_if and curtype=t_else then
begin str←str&"\2\&{"&curstr; getnext;
str←str&"} "&p_statement1&c2&p_comments;
end end;
[t_repeat] begin str←"\2\1\&{"&curstr; getnext;
str←str&"} "&p_statement1;
while curtype=semi2 do
begin str←str&curstr; getnext;
str←str&p_comments&p_statement;
end;
str←str&p_comments&c2&"\3\2\&{";
if curtype=t_until then
begin str←str&curstr; getnext;
end
else error2("Missing `until'");
str←str&"} "&p_genexp&c2 end;
[t_case] begin str←"\2\1\&{"&curstr; getnext;
str←str&"} "&p_genexp;
if curtype = t_of then
begin str←str&" \&{"&curstr&"}"; getnext;
end
else error2("Missing `of'");
str←str&p_case;
while curtype=semi2 do
begin str←str&curstr; getnext;
str←str&p_case;
end;
str←str&p_comments;
if curtype=t_end then
begin str←str&c2&"\2\&{"&curstr&("}\3"&c2); getnext;
end
else begin error2("Missing `end'"); str←str&("\3\2"&c2);
end end;
else begin str←p_genexp; if str then str←"\0"&str end
end;
return(str);
end;
recursive string procedure p_statement;
begin string str;
case curtype of begin
[t_begin] begin str←str&"\2"; str←str&p_compoundstatement end;
[ident2][const2][t_title] if labelpresent then begin str←"\2"&curstr&": ";
getnext; str←str&p_statement1 end
else str←str&p_noncompoundstatement;
else str←str&p_noncompoundstatement
end;
return(str);
end;
recursive string procedure p_case;
begin string str;
str←p_comments;
case curtype of begin
[ident2][const2][t_title] begin str←str&c2&"\2\1"; while true do
begin case curtype of begin
[comma2] begin str←str&curstr&"\45\ "; getnext end;
[t_comment] begin str←str&"\40\ "&curstr; getnext end;
[colon2] begin str←str&curstr&" "; getnext; done end;
[ident2][const2][t_title] begin str←str&curstr; getnext end;
else return(str&"\3")
end;
end;
str←str&p_statement1&"\3" end;
else comment do nothing;
end;
return(str);
end;
comment Phase 1;
initio # initialize the input/output system;
nstrs←conroot←titlroot←0 # initialize the search trees;
xr[find("label",1)]←-t_label;
xr[find("else",1)]←-t_else;
xr[find("case",1)]←-t_case;
xr[find("array",1)]←-t_array;
xr[find("and",1)]←-t_div;
xr[find("begin",1)]←-t_begin;
xr[find("div",1)]←-t_div;
xr[find("const",1)]←-t_var;
xr[find("do",1)]←-t_then;
xr[find("downto",1)]←-t_to;
xr[find("function",1)]←-t_procedure;
xr[find("exit",1)]←-t_exit;
xr[find("end",1)]←-t_end;
xr[find("file",1)]←-t_file;
xr[find("for",1)]←-t_for;
xr[find("if",1)]←-t_if;
xr[find("goto",1)]←-t_packed;
xr[find("in",1)]←-t_to;
xr[find("initprocedure",1)]←-t_procedure;
xr[find("record",1)]←-t_record;
xr[find("of",1)]←-t_of;
xr[find("mod",1)]←-t_div;
xr[find("loop",1)]←-t_begin;
xr[find("nil",1)]←-t_nil;
xr[find("not",1)]←-t_packed;
xr[find("packed",1)]←-t_packed;
xr[find("or",1)]←-t_div;
xr[find("procedure",1)]←-t_procedure;
xr[find("program",1)]←-t_program;
xr[find("to",1)]←-t_to;
xr[find("segmented",1)]←-t_packed;
xr[find("repeat",1)]←-t_repeat;
xr[find("set",1)]←-t_file;
xr[find("then",1)]←-t_then;
xr[find("var",1)]←-t_var;
xr[find("type",1)]←-t_var;
xr[find("until",1)]←-t_until;
xr[find("while",1)]←-t_for;
xr[find("with",1)]←-t_for;
mem[0]←0; m←1; mm←memsize # initialize the memory pool;
txtptr←0 # initialize the list of stored texts;
inbuf←""; pageno←0; state←normal; texte←""; curdef←-1; brchar←'14;
cursec←0;
print("(",inputfile);
while true do
begin label scan # go here to scan a character without reading a new one;
if c='12 then lineno←lineno+1;
comment The next lines read one character of input;
while inbuf=0 do
begin if brchar='14 then
begin pageno←pageno+1; lineno←1; print(" ",pageno);
end;
inbuf←input(ichan,1);
if eof and inbuf=0 then go to phase2;
if pageno=1 and lineno=1 and equ(inbuf[1 to 9],"COMMENT ⊗") then
begin comment Skip TVedit directory page;
while brchar≠'14 and not eof do inbuf←input(ichan,1);
if eof then go to phase2;
inbuf←"";
end;
end;
c←lop(inbuf);
scan: case state+chartype[c] of begin
[normal+lf] begin state←normal1; texte←texte&c end;
[normal+lbrace] begin bal←1; state←title1 end;
[normal+rbrace] begin error("Extra }."); texte←texte&c end;
[normal+letter] begin id←c; state←ident; defplace←0; op←0 end;
[normal+space][normal+cr][normal+ff][normal+digit][normal+apost]
[normal+plus][normal+minus][normal+colon][normal+equals]
[normal+hash][normal+lpren][normal+rpren][normal+other] texte←texte&c;
[normal1+cr][normal1+ff] begin finishdef; state←skipcr end;
[normal1+space][normal1+lf][normal1+letter][normal1+digit][normal1+apost]
[normal1+plus][normal1+minus][normal1+colon][normal1+equals][normal1+lbrace]
[normal1+rbrace][normal1+lpren][normal1+rpren][normal1+hash][normal1+other]
begin state←normal; go to scan end;
[title1+lbrace] begin integer op; op←comt;
if texte then storetext else if curdef<0 then
begin cursec←cursec+1; op←newsec end; compile(op,txtptr);
state←skipcomment end;
[title1+space][title1+lf][title1+cr][title1+ff][title1+letter]
[title1+digit][title1+apost][title1+plus][title1+minus][title1+colon]
[title1+equals][title1+rbrace][title1+lpren][title1+rpren][title1+hash]
[title1+other] begin if texte then storetext;
state←skipspaces; deftype←0; go to scan end;
[skipspaces+ff][skipcomment+ff][title2+ff] begin state←normal;
error("Runaway commment (not complete at end of page), see line ");
print(tlineno,".") end;
[skipcomment+lbrace] begin bal←bal+1; lastc←c; texte←texte&c end;
[skipcomment+rbrace] begin bal←bal-1; if bal<0 then
begin if lastc≠c then error("Comment didn't end with }}.") else texte←
texte[1 to ∞-1]; while texte='40 do c←lop(texte);
while texte[∞ for 1]='40 do texte←texte[1 to ∞-1];
storetext; m←m-1 # the command was already compiled;
state←skipcr end else begin lastc←c; texte←texte&c end end;
[skipcomment+space][skipcomment+cr][skipcomment+letter]
[skipcomment+digit][skipcomment+apost][skipcomment+plus][skipcomment+minus]
[skipcomment+colon][skipcomment+equals][skipcomment+lpren]
[skipcomment+rpren][skipcomment+hash][skipcomment+other] begin lastc←c;
texte←texte&c end;
[skipspaces+letter][skipspaces+digit][skipspaces+apost][skipspaces+plus]
[skipspaces+minus][skipspaces+equals][skipspaces+lbrace][skipspaces+rbrace]
[skipspaces+colon][skipspaces+lpren][skipspaces+rpren][skipspaces+hash]
[skipspaces+other] begin state←title2; go to scan end;
[title2+space][title2+cr] begin texte←texte&" "; state←skipspaces end;
[title2+lbrace] begin texte←texte&c; bal←bal+1 end;
[title2+rbrace] begin bal←bal-1; if bal=0 then begin state←title3;
if texte[∞ to ∞]=" " then texte←texte[1 to ∞-1] # remove final space;
end else texte←texte&c end;
[title2+lf][title2+letter][title2+digit][title2+apost][title2+plus]
[title2+minus][title2+colon][title2+equals][title2+lpren][title2+rpren]
[title2+hash][title2+other] texte←texte&c;
[title3+plus] deftype←1;
[title3+colon] deftype←2;
[title3+hash] deftype←3;
[title3+minus] deftype←4;
[title3+equals] startdef # Title definition found;
[title3+lf][title3+cr][title3+ff][title3+letter][title3+digit]
[title3+apost][title3+lbrace][title3+rbrace][title3+lpren]
[title3+rpren][title3+other] begin comment Title use found; integer j;
compile(ttl,j←find(texte,0)); texte←case deftype of ("","+",":","#","-");
if info(xr[j])≠cursec then begin xref(cursec,xr[j]); xr[j]←mm end;
state←normal; go to scan end;
[const+letter] begin id←c; state←ident end;
[const+apost] radix←"""" # double-quote is transmitted to phase2;
[const+digit] begin val←radix&c; state←const1 end;
[const+ff][const+plus][const+minus][const+colon][const+equals]
[const+lbrace][const+rbrace][const+lpren][const+rpren][const+hash]
[const+other] begin if defplace then
error("Improper constant.") else texte←texte&accum&op;
state←normal; go to scan end;
[const1+digit] val←val&c;
[const1+space][const1+lf][const1+cr][const1+ff][const1+letter]
[const1+apost][const1+plus][const1+minus][const1+colon][const1+equals]
[const1+lbrace][const1+rbrace][const1+lpren][const1+rpren][const1+hash]
[const1+other] begin processcon;
if state≠const then go to scan end;
[ident+letter][ident+digit] id←id&c;
[ident+space][ident+lf][ident+cr][ident+ff][ident+apost][ident+plus]
[ident+minus][ident+colon][ident+equals][ident+lbrace][ident+rbrace]
[ident+lpren][ident+rpren][ident+hash][ident+other] begin integer k;
k←find(id,1); if xr[k]≥0 and info(xr[k])≠cursec then begin
xref(cursec,xr[k]); xr[k]←mm end;
if eq[k]<0 then
begin comment macro call;
finishid;
texte←texte&id;
go to scan;
end
else if eq[k]>0 then
begin val←id; processcon; if state≠const then go to scan
end
else begin finishid; texte←texte&id; go to scan end end;
[skipcr+lf] state←normal1;
[skipcr+letter][skipcr+digit][skipcr+apost][skipcr+plus]
[skipcr+minus][skipcr+colon][skipcr+equals][skipcr+lbrace][skipcr+rbrace]
[skipcr+lpren][skipcr+rpren][skipcr+hash][skipcr+other]
begin state←normal; go to scan end;
else comment do nothing;
end;
end;
comment Phase 2;
phase2: print(")"); release(ichan);
if texte then storetext;
if state=normal1 then finishdef
else if state≠normal then print(nextline,"Input ended unexpectedly.");
mem[m]←stop lsh 18 # This instruction will cause phase 2 to end;
m←1; cursec←0; out(ochan,"\input dochdr");
while true do
begin curtitle←0;
if cursec mod 10 = 0 then
begin if cursec then
begin print(" ",cursec div 10); out(ochan,""&'14);
end
else print(nextline&"[",outputfile);
end;
cursec←cursec+1;
case info(m) of begin
[stop] begin print(" ",(cursec+9)div 10,"]"); done end;
[newsec] begin out(ochan,nextline&nextline&"\secbegin ");
out(ochan,texts[link(m)]); m←m+1 end;
[def0][def1] begin out(ochan,nextline&nextline&"\secbegin ");
curtitle←link(m); out(ochan,p_title(curtitle));
if nn≠cursec then curtitle←0;
if info(m)=def0 then out(ochan," \.=\par") else out(ochan," \.{+=}\par");
m←m+1 end;
else print(nextline,".DOC file should begin with a comment")
end;
lastout←cr2; inbuf←curbuf←null;
getnext;
if curtype≠t_eof then
begin out(ochan,nextline&"\pascal"&nextline);
case curtype of begin
[t_program][t_var][t_procedure][t_label][t_begin][t_def2][t_def3]
[t_def4]
out(ochan,"\1") # one extra unit of indent applying to the code;
else comment do nothing;
end;
while curtype≠t_eof do
begin activity←false;
while true do
begin case curtype of begin
[dot2][semi2] ;
[t_comment] curstr←"\40\ "&curstr;
else done
end;
putstr←curstr; putout; getnext;
end;
putstr←cr2&p_fragment; putout;
if not activity then
begin error2("Uninterpretable fragment"); getnext;
end;
end;
end;
if curtitle then
begin comment Completion of a title definition;
if eq[curtitle]<0 then
begin integer p;
out(ochan,nextline&nextline&"\note See also section");
p←reverse(-eq[curtitle]);
outlist(link(p));
p←reverse(p);
end;
if xr[curtitle] then
begin out(ochan,nextline&nextline&
"\note This code is used in section");
outlist(reverse(xr[curtitle]));
end
else print(nextline,"Unused title: {",str[curtitle]);
end;
end;
out(ochan,nextline&nextline&"\index"&nextline);
outtree(conroot);
out(ochan,"\endindex"&nextline);
finalend: release(ochan);
end